home *** CD-ROM | disk | FTP | other *** search
/ PC-SIG: World of Games / PC-SIG World of Games (CDRM1080710) (1993).iso / 749 / LOTTERY.PAS < prev    next >
Pascal/Delphi Source File  |  1986-11-08  |  52KB  |  1,953 lines
  1. {
  2. This program is based on the MD LOTTO.  It was developed as a training
  3. exercise that got out of hand and became a home project for a potentially
  4. salable product.
  5. }
  6.  
  7.  
  8. PROGRAM LOTTERY(INPUT,OUTPUT);
  9.  
  10. {$I-}  {IGNORE I/O ERRORS)
  11. {$R+}  {SET UP RANGE AND BOUNDS CHECKING}
  12.      {GLOBAL CONSTANTS AND TYPES}
  13.  
  14. CONST
  15.       RELNO = 1.003; {RELEASE NUMBER}
  16.       NUMPIC = 6;
  17.       MAXNUM = 40;
  18.       TKTMAX = 200;
  19.  
  20. TYPE
  21.       LOTNUMS = 1 .. MAXNUM;
  22.       TKT = ARRAY [1..NUMPIC] OF LOTNUMS;
  23.       TKTAR = ARRAY [1..TKTMAX] OF TKT;
  24.       OPT = (Y,N);
  25.       TICKETRECORD = RECORD TICKET:TKT; END;
  26.       TKTFILE = FILE OF TICKETRECORD;
  27.       FILENAME = STRING[32];
  28.       DIRECTARRAY = ARRAY [1..100] OF FILENAME;
  29. VAR
  30.       WTKT,CTKT                                          : TKT;
  31.       TKTS                                               : TKTAR;
  32.       NUMTKTS, I, J, K, ARRAYSIZE                        : INTEGER;
  33.       WINNERVALID                                        : BOOLEAN;
  34.       PWPRINT, PWDISP, AUTOPRINT, AUTODISP               : OPT;
  35.       TKTREC                                             : TICKETRECORD;
  36.       INFILE, OUTFILE                                    : TKTFILE;
  37.       STARTBYTE, POKEBYTE, NOWBYTE, OLDCON               : BYTE;
  38.  
  39. CONST {TYPED}
  40.       IOVal    : Integer = 0;
  41.       IOErr    : Boolean = False;
  42.  
  43. {
  44.      These procedures CHIRP, BEEP, BEEPBEEP, HILOTONE, SIREN, and ALERT1
  45. provide the bells and whistles that are used throughout the program.
  46. }
  47.  
  48. PROCEDURE CHIRP;
  49.  
  50. BEGIN
  51. SOUND (500);
  52. DELAY (200);
  53. NOSOUND;
  54. END;
  55.  
  56.  
  57. PROCEDURE BEEP;
  58.  
  59. BEGIN
  60. SOUND(750);
  61. DELAY(250);
  62. NOSOUND;
  63. END {PROC};
  64.  
  65.  
  66. PROCEDURE BEEPBEEP(I:INTEGER);
  67.  
  68. VAR J:INTEGER;
  69.  
  70. BEGIN
  71. FOR J := 1 TO I DO BEGIN BEEP; DELAY(175); END;
  72. END {PROC};
  73.  
  74.  
  75. PROCEDURE HILOTONE(I:INTEGER);
  76.  
  77. VAR J:INTEGER;
  78.  
  79. BEGIN
  80. FOR J := 1 TO I DO BEGIN
  81.    SOUND (1000);
  82.    DELAY (500);
  83.    NOSOUND;
  84.    SOUND (500);
  85.    DELAY (500);
  86.    NOSOUND;
  87. END {DO};
  88. END {PROC};
  89.  
  90.  
  91. PROCEDURE SIREN(I:INTEGER);
  92.  
  93. VAR J,K:INTEGER;
  94.  
  95. BEGIN
  96. FOR J := 1 TO I DO BEGIN
  97.    FOR K := 500  TO     2000 DO BEGIN SOUND(K);DELAY(1);END;
  98.    FOR K := 2000 DOWNTO  500 DO BEGIN SOUND(K);DELAY(1);END;
  99. END {DO};
  100. NOSOUND;
  101. END {PROC};
  102.  
  103. PROCEDURE YELP(I:INTEGER);
  104.  
  105. VAR J,K:INTEGER;
  106.  
  107. BEGIN
  108. FOR J := 1 TO I DO BEGIN
  109.    FOR K := 1 TO 500 DO BEGIN SOUND(2000 - (3 * K));DELAY(1);END;
  110.    FOR K := 1 TO 500 DO BEGIN SOUND(2000 - (3 * K));DELAY(1);END;
  111. END {DO};
  112. NOSOUND;
  113. END {PROC};
  114.  
  115.  
  116. PROCEDURE ALERT1(I:INTEGER);
  117.  
  118. VAR J,K:INTEGER;
  119.  
  120. BEGIN
  121. FOR J := 1 TO I DO BEGIN
  122.    FOR K := 1 TO 500 DO BEGIN SOUND(500 + (3 * K));DELAY(1);END;
  123.    FOR K := 1 TO 500 DO BEGIN SOUND(500 + (3 * K));DELAY(1);END;
  124. END {DO};
  125. NOSOUND;
  126. END {PROC};
  127.  
  128.  
  129. PROCEDURE HILITE;
  130.  
  131. BEGIN
  132. TEXTCOLOR (YELLOW);
  133. TEXTBACKGROUND (BLACK);
  134. END;
  135.  
  136.  
  137. PROCEDURE LOLITE;
  138.  
  139. BEGIN
  140. TEXTCOLOR (YELLOW);
  141. TEXTBACKGROUND (BLUE);
  142. END;
  143.  
  144.  
  145. PROCEDURE SCRNRESET; {GENERAL SCREEN RESET YELLOW ON BLUE}
  146.  
  147. BEGIN
  148. WINDOW(1,1,80,25);
  149. TEXTCOLOR (YELLOW);
  150. TEXTBACKGROUND (BLUE);
  151. CLRSCR;
  152. END {PROC};
  153.  
  154. { *** RANDOMIZE, IOCHECK AND DOS DIRECTORY CALL PROCEDURES ADAPTED FROM
  155.       TURBO PASCAL 2.0 WITH PERMISSION OF BORLAND INTERNATIONAL AS
  156.       STATED IN THEIR DOCUMENTATION
  157.       }
  158.  
  159. procedure IOCheckA;
  160. {
  161.        This routine sets IOErr equal to IOresult, then sets
  162.        IOFlag accordingly.  It is a subset of routine IOCHECK.
  163. }
  164. var
  165.   Ch                   : Char;
  166. begin
  167.   IOVal := IOresult;
  168.   IOErr := (IOVal <> 0);
  169. end {proc};
  170.  
  171.  
  172. procedure IOCheck;
  173. {
  174.        This routine sets IOErr equal to IOresult, then sets
  175.        IOFlag accordingly.  It also prints out a message on
  176.        the 25th line of the screen, then waits for the user
  177.        to hit any character before proceding.
  178. }
  179. var
  180.   Ch                   : Char;
  181. begin
  182.   IOVal := IOresult;
  183.   IOErr := (IOVal <> 0);
  184.   if IOErr then begin
  185.     GoToXY(1,25); ClrEol; {CLEAR ANYTHING ON LINE 25}
  186.     BEEPBEEP(2);
  187.     case IOVal of
  188.       $01  :  Write('File does not exist');
  189.       $02  :  Write('File not open for input');
  190.       $03  :  Write('File not open for output');
  191.       $04  :  Write('File not open');
  192.       $05  :  Write('Can''t read from this file');
  193.       $06  :  Write('Can''t write to this file');
  194.       $10  :  Write('Error in numeric format');
  195.       $20  :  Write('Operation not allowed on a logical device');
  196.       $21  :  Write('Not allowed in direct mode');
  197.       $22  :  Write('Assign to standard files not allowed');
  198.       $90  :  Write('Record length mismatch');
  199.       $91  :  Write('Seek beyond end of file');
  200.       $99  :  Write('Unexpected end of file');
  201.       $F0  :  Write('Disk write error');
  202.       $F1  :  Write('Directory is full');
  203.       $F2  :  Write('File size overflow');
  204.       $FF  :  Write('File disappeared')
  205.     else      Write('Unknown I/O error:  ',IOVal:3)
  206.     end{case};
  207.     Read(Kbd,Ch);
  208.     GoToXY(1,25);
  209.     ClrEol;
  210.   end{if};
  211. end; { of proc IOCheck }
  212.  
  213.  
  214. {
  215.    Randomize Procedure For MS-DOS & PC-DOS Turbo Pascal
  216.  
  217.    This new Randomize has two Integer parameters.  If they are both 0, then
  218. the random number seed is set randomly.  If either of the parameters is
  219. nonzero, then they are both stored directly into the 32 bit seed.
  220.  
  221.    To set the seed randomly (Randomize(0,0)), the procedure calls MS-DOS
  222. to get the current time.  This is a 32 bit value, which is also stored
  223. directly into the seed.  On some systems, (i.e. the NCR Decision Mate V),
  224. the clock does not tick, so the time never changes.  Randomize checks this,
  225. and if the clock hasn't changed after a Delay(100), it asks the user to hit
  226. a key.  While waiting for the key, it continuously increments two counters.
  227. These are then stored into the seed.
  228.  
  229. { Please note:  This routine is for MS-Dos/PC-Dos Turbo ONLY! }
  230.  
  231. procedure Randomize(I,J: Integer);
  232.  
  233. var
  234.   RSet    : record
  235.               AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer;
  236.             end;
  237.   Ch      : Char;
  238.  
  239. begin
  240.   if (I=0) and (J=0) then begin     { Generate a random random number seed }
  241.     RSet.AX:=$2C00;                             { DOS time of day function }
  242.     MSDos(RSet);
  243.     I:=RSet.CX;                           { Set I and J to the system time }
  244.     J:=RSet.DX;
  245.     Delay(100);   { This delay may have to be increased for faster systems }
  246.     MSDos(RSet);
  247.     if (I=RSet.CX) and (J=RSet.DX) then begin        { Clock isn't ticking }
  248.       I := 0;
  249.       J := 0;
  250.       while KeyPressed do
  251.         Read(Kbd,Ch);                              { Clear keyboard buffer }
  252.       Write('Hit any key to set the random number generator: ');
  253.       repeat
  254.         I := I+13;
  255.         J := J+17
  256.       until Keypressed;
  257.       Read(Kbd,Ch);                                 { Absorb the character }
  258.       WriteLn
  259.     end
  260.   end;
  261.   MemW[DSeg:$129]:=I;  { This is the core of the routine: store a 32 bit }
  262.   MemW[DSeg:$12B]:=J;  {  seed at locations DSeg:$0129...DSeg:$012C      }
  263. end; { of procedure Randomize }
  264.  
  265.  
  266. PROCEDURE DirList (VAR DirArray  : DirectArray;
  267.                    VAR ArraySize : INTEGER);
  268.  
  269. {
  270.        This is a simple procedure to build an array of names
  271.        out the directory of the current (logged) drive.
  272. }
  273. type
  274.   Char12arr            = array [ 1..12 ] of Char;
  275.   String20             = string[ 20 ];
  276.   RegRec =
  277.     record
  278.       AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer;
  279.     end;
  280.  
  281. var
  282.   Regs                 : RegRec;
  283.   DTA                  : array [ 1..43 ] of Byte;
  284.   Mask                 : Char12arr;
  285.   NamR                 : String20;
  286.   Error, I, KK         : Integer;
  287.  
  288. begin { main body of procedure DirList }
  289.  
  290.   ArraySize := 0;
  291.   FOR KK := 1 TO 100 DO DIRARRAY[KK] := '';
  292.   FillChar(DTA,SizeOf(DTA),0);        { Initialize the DTA buffer }
  293.   FillChar(Mask,SizeOf(Mask),0);      { Initialize the mask }
  294.   FillChar(NamR,SizeOf(NamR),0);      { Initialize the file name }
  295.  
  296.   Regs.AX := $1A00;         { Function used to set the DTA }
  297.   Regs.DS := Seg(DTA);      { store the parameter segment in DS }
  298.   Regs.DX := Ofs(DTA);      {   "    "      "     offset in DX }
  299.   MSDos(Regs);              { Set DTA location }
  300.   Error := 0;
  301.   Mask := '????????.LFD';    { Use global search }
  302.   Regs.AX := $4E00;          { Get first directory entry }
  303.   Regs.DS := Seg(Mask);      { Point to the file Mask }
  304.   Regs.DX := Ofs(Mask);
  305.   Regs.CX := 22;             { Store the option }
  306.   MSDos(Regs);               { Execute MSDos call }
  307.   Error := Regs.AX and $FF;  { Get Error return }
  308.   I := 1;                    { initialize 'I' to the first element }
  309.   if (Error = 0) then BEGIN
  310.     repeat
  311.       NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
  312.       I := I + 1;
  313.     until not (NamR[I-1] in [' '..'~']) or (I>20);
  314.  
  315.     NamR[0] := Chr(I-1);          { set string length because assigning }
  316.                                   { by element does not set length }
  317.     ArraySize := 1;
  318.     DirArray[ArraySize] := NAMR;
  319.   END{IF};
  320.   while (Error = 0) do begin
  321.     Error := 0;
  322.     Regs.AX := $4F00;           { Function used to get the next }
  323.                                 { directory entry }
  324.     Regs.CX := 22;              { Set the file option }
  325.     MSDos( Regs );              { Call MSDos }
  326.     Error := Regs.AX and $FF;   { get the Error return }
  327.     I := 1;
  328.     repeat
  329.       NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
  330.       I := I + 1;
  331.     until not (NamR[I-1] in [' '..'~'] ) or (I > 20);
  332.     NamR[0] := Chr(I-1);
  333.     if (Error = 0) THEN BEGIN
  334.       ArraySize := ArraySize + 1;
  335.       DirArray[ArraySize] := NAMR;
  336.     END {IF};
  337.   end{WHILE};
  338. end{ of procedure DirList  };
  339.  
  340. {
  341. This procedure outputs the array generated in Dirlist and generates the
  342. user screen display in 6 wide format.
  343. }
  344.  
  345.  
  346. PROCEDURE DISPDIR;
  347.  
  348. LABEL
  349.     EXIT;
  350.  
  351. VAR
  352.     DIRARRAY                      : DIRECTARRAY;
  353.     ARRAYSIZE, I, J, K, M         : INTEGER;
  354.     CH                            : CHAR;
  355.  
  356. BEGIN
  357. SCRNRESET;
  358. DIRLIST(DIRARRAY,ARRAYSIZE);
  359. GOTOXY (33,2);
  360. WRITELN ('LIST OF FILES');
  361. WRITELN;
  362. IF ARRAYSIZE < 1 THEN GOTO EXIT;
  363.  
  364.                   {PRINT 6 WIDE WITHOUT THE .LPD SUFFIX}
  365.  
  366. I := 1;
  367. J := 6;
  368. REPEAT
  369.   IF J > ARRAYSIZE THEN J := ARRAYSIZE;  {MAKE SURE NOT TO PRINT TOO MANY}
  370.   FOR K := I TO J DO BEGIN
  371.     WHILE ((LENGTH (DIRARRAY[K]) > 0) AND (DIRARRAY[K][1] = ' ')) DO BEGIN
  372.        DELETE (DIRARRAY[K],1,1); {TRIM LEADING BLANKS}
  373.     END {DO};
  374.     WHILE ((LENGTH (DIRARRAY[K]) > 0)
  375.             AND (DIRARRAY[K][LENGTH(DIRARRAY[K])] = ' ')) DO BEGIN
  376.       DELETE (DIRARRAY[K], (LENGTH(DIRARRAY[K])), 1); {TRIM TRAILING BLANKS}
  377.     END {DO};
  378.                     {TRIM TO SHOW FILE NAME ONLY}
  379.     IF LENGTH (DIRARRAY[K]) > 8 THEN DELETE (DIRARRAY[K], 9, 32);
  380.     M := POS ('.',DIRARRAY[K]);
  381.     IF M > 0 THEN DELETE (DIRARRAY[K], M, 8);
  382.     IF K = I THEN
  383.        WRITE (DIRARRAY[K]:15) {WRITE IN A 15 COLUMN FIELD}
  384.     ELSE
  385.        WRITE (DIRARRAY[K]:12) {WRITE IN A 15 COLUMN FIELD}
  386.     {ENDIF};
  387.   END {DO};
  388.   WRITELN;
  389.   I := I + 6; {INCREMENT LINE POINTER}
  390.   J := I + 5;
  391. UNTIL I > ARRAYSIZE;
  392. WRITELN;
  393. WRITELN;
  394. GOTOXY (28,WHEREY);
  395. WRITELN ('PRESS ANY KEY TO CONTINUE');
  396. READ (KBD,CH);
  397. CLRSCR;
  398. EXIT: END {PROC};
  399.  
  400.  
  401. {
  402. This procedure initializes the major common variables of the program and
  403. effectively acts as a data reset function.
  404. }
  405.  
  406. PROCEDURE REINIT;
  407.  
  408. VAR I, J : INTEGER;
  409.  
  410. BEGIN
  411. WINNERVALID := FALSE;
  412. NUMTKTS := 0;
  413. FOR I := 1 TO TKTMAX DO FOR J := 1 TO NUMPIC DO TKTS[I,J] := MAXNUM;
  414. FOR I := 1 TO NUMPIC DO WTKT[I] := MAXNUM;
  415. END{PROC};
  416.  
  417.  
  418.  
  419. {
  420. This procedure allows the changing of the print and display options for the
  421. program.
  422.  
  423. It uses a case procedure to toggle the control variable for each parameter.
  424.  
  425. A test for value 0 is used for termination and return to the main program.
  426. }
  427.  
  428. PROCEDURE OPTMENU;
  429.  
  430. VAR ANSWER : INTEGER;
  431.  
  432. BEGIN
  433. REPEAT
  434.    SCRNRESET;
  435.    GOTOXY (34,2);
  436.    WRITELN ('OPTIONS MENU');
  437.    GOTOXY (1,5);
  438.    WRITELN ('0.  EXIT MEMU');
  439.    WRITELN;
  440.    IF PWPRINT = Y THEN BEGIN
  441.       WRITELN ('1.  PRINT WINNERS WHEN FOUND   = YES.');END
  442.    ELSE  BEGIN
  443.       WRITELN ('1.  PRINT WINNERS WHEN FOUND   = NO.');
  444.    END{IF};
  445.    IF PWDISP = Y THEN BEGIN
  446.       WRITELN ('2.  DISPLAY WINNERS WHEN FOUND = YES.');END
  447.    ELSE BEGIN
  448.       WRITELN ('2.  DISPLAY WINNERS WHEN FOUND = NO.');
  449.    END{IF};
  450.    WRITELN;
  451.    IF AUTOPRINT = Y THEN BEGIN
  452.       WRITELN ('3.  AUTOPRINT TICKETS   = YES.');END
  453.    ELSE BEGIN
  454.       WRITELN ('3.  AUTOPRINT TICKETS   = NO.');
  455.    END{IF};
  456.    IF AUTODISP = Y THEN BEGIN
  457.       WRITELN ('4.  AUTODISPLAY TICKETS = YES.');END
  458.    ELSE BEGIN
  459.       WRITELN ('4.  AUTODISPLAY TICKETS = NO.');
  460.    END{IF};
  461.    GOTOXY (10,20);
  462.    WRITE ('ENTER SELECTION TO CHANGE.   ');
  463.    ANSWER := 30; {STORE DEFAULT VALUE TO CAUSE RECYCLE}
  464.    READLN (ANSWER);
  465.    IOCHECKA;
  466.    IF IOERR = TRUE THEN ANSWER := 30; {ON ERROR RELOAD INVALID ANSWER}
  467.    CASE ANSWER OF
  468.    0 :  {NO OPERATION};
  469.    1 :  IF PWPRINT = Y THEN PWPRINT := N ELSE PWPRINT := Y;
  470.    2 :  IF PWDISP = Y THEN PWDISP := N ELSE PWDISP := Y;
  471.    3 :  IF AUTOPRINT = Y THEN AUTOPRINT := N ELSE AUTOPRINT := Y;
  472.    4 :  IF AUTODISP = Y THEN AUTODISP := N ELSE AUTODISP := Y;
  473.    ELSE BEEP
  474. END{CASE};
  475. UNTIL ANSWER = 0;
  476. END{PROC};
  477.  
  478.  
  479. {
  480. This procedure compares two tickets and keeps track of the number of matches.
  481. As it is called very, very frequently, quick end tests are made to cut the
  482. number of comparisons made to a minimum.  If 3 misses on a ticket are
  483. accumulated, the tickets cannot be matched and the comparison terminates.
  484. Win is set to the number of matches if 4 or more matches occur.  Otherwise
  485. a 0 is returned.
  486. }
  487.  
  488.  
  489.  
  490. PROCEDURE COMPARE(TICK1,TICK2               :TKT;
  491.                   VAR WIN                   :INTEGER);
  492.  
  493. VAR   POINT1,POINT2,MISS1,MISS2,HIT         :INTEGER;
  494.       DONE                                  :BOOLEAN;
  495.  
  496. BEGIN
  497.                {INITIALIZE VARIABLES}
  498. POINT1 := 1 ;
  499. POINT2 := 1 ;
  500. WIN    := 0 ;
  501. MISS1  := 0 ;
  502. MISS2  := 0 ;
  503. HIT    := 0 ;
  504.  
  505.                {BEGIN EXAMINING THE TICKETS FOR A MATCH}
  506.  
  507. DONE   := FALSE;
  508. REPEAT
  509.   IF (TICK1[POINT1] = TICK2[POINT2]) THEN  {COMPARE NUMBER ON EACH TICKET}
  510.      BEGIN {TRUE}
  511.      HIT := HIT + 1                        {A HIT, TRY FOR 6};
  512.      POINT1 := POINT1 + 1 ;                {INDEXING POINTERS}
  513.      POINT2 := POINT2 + 1 ;
  514.      END {TRUE BRANCH}
  515.   ELSE                                      {A MISS}
  516.      BEGIN {FALSE PATH}
  517.      {INDEX MISS COUNT AND POINTER OF TICKET WITH SMALLEST NUMBER}
  518.      IF (TICK1[POINT1] > TICK2[POINT2]) THEN
  519.         BEGIN {A MISS ON TICKET 2}
  520.         MISS2  := MISS2  + 1 ;
  521.         POINT2 := POINT2 + 1 ;
  522.         END {TICKET 2 MISS}
  523.      ELSE
  524.         BEGIN {MISS ON TICKET 1}
  525.         MISS1  := MISS1  + 1 ;
  526.         POINT1 := POINT1 + 1 ;
  527.         END {TICKET 1 MISS}
  528.      {ENDIF}
  529.      END {FALSE PATH}
  530.   {ENDIF};
  531.  
  532.   {TEST FOR DONE, 3 MISSES ON A TICKET OR OUT OF NUMBERS TO COMPARE}
  533.   IF ((MISS1 > 2) OR (MISS2 > 2) OR (POINT1 > NUMPIC) OR (POINT2 > NUMPIC))
  534.      THEN DONE := TRUE;
  535. UNTIL (DONE = TRUE);
  536. {TEST AND REPORT A WIN IF OVER 3 HITS}
  537. IF (HIT > 3) THEN WIN := HIT;
  538. END;
  539.  
  540.  
  541. {
  542. This procedure will print or display winning tickets based on the option
  543. variables.  A variety of bells and whistles are used to alert various
  544. levels of wins.  If PWDISP and PWPRINT are both N this routine will produce
  545. no output.
  546. }
  547.  
  548. PROCEDURE PWIN(TKTNO,WINSIZE        :INTEGER;
  549.                PTKT,WTKT            :TKT;
  550.                PWPRINT,PWDISP       :OPT);
  551.  
  552.  
  553. VAR  I                              : INTEGER;
  554.  
  555. BEGIN
  556.  
  557. HILITE;
  558. CLRSCR;
  559.  
  560. IF PWDISP = Y THEN {WRITE TO SCREEN}
  561. BEGIN
  562.    WRITELN;
  563.    WRITELN ('   !!!   YOU HAVE A WINNER   !!!   ');
  564.    FOR I := 1 TO 3 DO WRITELN;
  565.    WRITELN ('TICKET NO: ',TKTNO:4,'.');
  566.    WRITELN;
  567.    WRITELN ('WINSIZE:',WINSIZE:4,'.');
  568.    WRITELN;
  569.    WRITE ('PICK Nos:');
  570.    FOR I := 1 TO NUMPIC DO WRITE (PTKT[I]:6);
  571.    WRITELN;
  572.    WRITELN;
  573.    WRITE ('THE LOTTO DRAW WAS:');
  574.    FOR I:= 1 TO NUMPIC DO WRITE (WTKT[I]:6);
  575.    WRITELN;
  576.    WRITELN;
  577.    CASE WINSIZE OF {CELEBRATION WORDS AND MUSIC}
  578.    4 : BEEPBEEP(3);
  579.    5 : BEGIN
  580.           WRITELN ('   !!!   AND IT`S A BIG ONE   !!!');
  581.           YELP(3);
  582.        END;
  583.    6 : BEGIN
  584.           WRITELN ('          !!!  YOU`RE RICH  !!!');
  585.           WRITELN;
  586.           WRITELN ('RICH I TELL YOU!...  RICH RICH RICH !!!!');
  587.           WRITELN;
  588.           WRITELN ('RETIRE NOW, AVOID THE RUSH');
  589.           WRITELN;
  590.           WRITELN ('YOU MAY EXIT THE PROGRAM AND SHUT OFF THE COMPUTER');
  591.           WRITELN;
  592.           WRITELN ('              WHEN YOU WAKE UP');
  593.           SIREN(2);
  594.           DELAY(10);
  595.           YELP(3);
  596.           DELAY(10);
  597.           ALERT1(3);
  598.           DELAY(10);
  599.        END;
  600.    END{CASE};
  601.    GOTOXY(1,25);
  602.    CLREOL;
  603.    WRITE ('PRESS ANY KEY TO CONTINUE');
  604.    REPEAT BEGIN END UNTIL KEYPRESSED;
  605.    READ (KBD);
  606.    CLRSCR;
  607. END {IF};
  608.  
  609. IF PWPRINT = Y THEN {WRITE TO PRINTER}
  610. BEGIN
  611.    WRITELN (LST);
  612.    WRITELN (LST,'   !!!   YOU HAVE A WINNER   !!!   ');
  613.    FOR I := 1 TO 3 DO WRITELN (LST);
  614.    WRITELN (LST,'TICKET NO: ',TKTNO:4,'.');
  615.    WRITELN (LST);
  616.    WRITELN (LST,'WINSIZE:',WINSIZE:4,'.');
  617.    WRITELN (LST);
  618.    WRITE (LST,'PICK Nos:');
  619.    FOR I := 1 TO NUMPIC DO WRITE (LST,PTKT[I]:6);
  620.    WRITELN (LST);
  621.    WRITELN (LST);
  622.    WRITE (LST,'THE LOTTO DRAW WAS:');
  623.    FOR I:= 1 TO NUMPIC DO WRITE (LST,WTKT[I]:6);
  624.    FOR I := 1 TO 4 DO WRITELN (LST);
  625.    WRITELN (LST);
  626.    WRITELN (LST);
  627.    IF ((PWDISP = N) AND (PWPRINT = Y)) THEN BEGIN { WHEN PRINTING ONLY}
  628.       CASE WINSIZE OF {CELEBRATION WORDS AND MUSIC}
  629.       4 : BEEPBEEP(3);
  630.       5 : BEGIN
  631.              WRITELN (LST,'   !!!   AND IT`S A BIG ONE   !!!');
  632.              YELP(3);
  633.           END;
  634.       6 : BEGIN
  635.              WRITELN (LST,'          !!!  YOU`RE RICH  !!!');
  636.              WRITELN (LST);
  637.              WRITELN (LST,'RICH I TELL YOU!...  RICH RICH RICH !!!!');
  638.              WRITELN (LST);
  639.              WRITELN (LST,'RETIRE NOW, AVOID THE RUSH');
  640.              WRITELN (LST);
  641.              WRITELN (LST,'YOU MAY EXIT THE PROGRAM AND SHUT OFF THE COMPUTER');
  642.              WRITELN (LST,'              WHEN YOU WAKE UP');
  643.              SIREN(2);
  644.              DELAY(10);
  645.              YELP(3);
  646.              DELAY(10);
  647.              ALERT1(3);
  648.              DELAY(10);
  649.           END;
  650.       END{CASE};
  651.    END{IF};
  652.    FOR I := 1 TO 2 DO WRITELN (LST);
  653. END{IF};
  654. END{PROC};
  655.  
  656. {
  657. This procedure uses the compare procedure to test for winning tickets,
  658. and then calls pwin in case of winners to print out the winners to screen or
  659. printer.  A summary of the tickets scanned is displayed at the end of the
  660. procedure.
  661. }
  662.  
  663. PROCEDURE SCANTKTS;
  664.  
  665. VAR
  666.    I, WIN, WIN4, WIN5, WIN6, LOSERS        : INTEGER;
  667.    CTKT                                    : TKT;
  668.  
  669. BEGIN {PROC}
  670. {INITIALIZE VARIABLES}
  671. WIN4   := 0;
  672. WIN5   := 0;
  673. WIN6   := 0;
  674. LOSERS := 0;
  675. SCRNRESET;
  676. FOR I := 1 TO NUMTKTS DO
  677.     BEGIN {DO}
  678.     CTKT := TKTS[I];                {SELECT A TICKET}
  679.     COMPARE(CTKT,WTKT,WIN);  {COMPARE WITH WINNING NOS.}
  680.     IF (WIN > 3) THEN               {TEST FOR A WINNER, WIN>3}
  681.        BEGIN {TRUE}
  682.        PWIN(I,WIN,CTKT,WTKT,PWPRINT,PWDISP); {PRINT WINNING TICKET}
  683.        CASE WIN OF
  684.           4:   WIN4 := WIN4 + 1;
  685.           5:   WIN5 := WIN5 + 1;
  686.           6:   WIN6 := WIN6 + 1;
  687.        END {CASE}
  688.        END {TRUE}
  689.     ELSE
  690.        LOSERS := LOSERS + 1
  691.     {ENDIF}
  692. END {DO} ;
  693. SCRNRESET;
  694. WINDOW (3,3,77,22);
  695. HILITE;
  696. CLRSCR;
  697. WINDOW (4,3,77,22);
  698. WRITELN;
  699. WRITELN ('THERE WERE ',NUMTKTS,' TICKETS CHECKED.');
  700. WRITELN;
  701. WRITELN ('THERE WERE ',WIN4,' TICKET(S) WITH 4 MATCHING NUMBERS.');
  702. WRITELN;
  703. WRITELN ('THERE WERE ',WIN5,' TICKET(S) WITH 5 MATCHING NUMBERS.');
  704. WRITELN;
  705. WRITELN ('THERE WERE ',WIN6,' JACKPOT TICKET(S).');
  706. WRITELN;
  707. WRITELN ('THERE WERE ',LOSERS,' LOSERS.');
  708. GOTOXY (10,20);
  709. WRITE ('PRESS ANY KEY TO CONTINUE');
  710. REPEAT UNTIL KEYPRESSED;
  711. READ (KBD);
  712. SCRNRESET;
  713. END {PROC};
  714.  
  715. {
  716. This procedure sorts the elements of a ticket into ascending order
  717. }
  718.  
  719. PROCEDURE SORTPICK (VAR STKT:TKT);
  720.  
  721. VAR
  722.    I, J, TEMP           : INTEGER;
  723.  
  724. BEGIN
  725.  
  726. FOR I := 1 TO (NUMPIC - 1) DO BEGIN
  727.    FOR J := (I + 1) TO NUMPIC DO BEGIN
  728.       IF (STKT[I] > STKT[J]) THEN BEGIN
  729.          TEMP := STKT[I];
  730.          STKT[I] := STKT[J];
  731.          STKT[J] := TEMP;
  732.       END {IF};
  733.    END {DO};
  734. END {DO};
  735. END; {PROC}
  736.  
  737.  
  738. {
  739. This procedure generates a ticket using the random number generator.
  740. Nupic number of pics are generated.  The ticket is sorted, and checked
  741. for duplicates.  If no duplicates are found then the ticket is accepted.
  742. Otherwise, a new number is issued for one of the duplicates and the new
  743. ticket is retested.
  744. }
  745. PROCEDURE GENTKT (VAR RNDTKT:TKT);
  746.  
  747. VAR I,J,TEMP           :INTEGER;
  748.     FAULT              :BOOLEAN;
  749.  
  750. BEGIN {PROC}
  751.  
  752. FOR I := 1 TO NUMPIC DO RNDTKT[I] := (RANDOM(MAXNUM)) + 1;
  753. REPEAT
  754.    SORTPICK (RNDTKT); {SORT THE ENTRYS}
  755.    FAULT := FALSE;
  756.    FOR I := 1 TO (NUMPIC - 1) DO BEGIN {CHECK FOR INVALID TICKET,
  757.                               i.e. DUPLICATE PICK NUMBERS}
  758.       J := I + 1;
  759.       IF (RNDTKT[I] = RNDTKT[J]) THEN BEGIN {DUPLICATE FOUND}
  760.         FAULT := TRUE; {SET FOR RECHECK}
  761.         RNDTKT[J] := (RANDOM(MAXNUM)) + 1; {REPLACE WITH NEW PICK}
  762.       END {IF}
  763.    END; {DO}
  764. UNTIL FAULT = FALSE;
  765. END; {PROC}
  766.  
  767. {
  768. This procedure generates a complete set of tickets for a simulation run.
  769. The value of numtkts is used to determine the number of tickets to generate.
  770. }
  771.  
  772.  
  773. PROCEDURE SIMULATE;
  774.  
  775. VAR I : INTEGER;
  776.  
  777. BEGIN {PROC}
  778. FOR I := 1 TO NUMTKTS DO GENTKT(TKTS[I]); {GENERATE NUMTKTS NUMBER OF RANDOM
  779.                                             LOTTERY TICKETS}
  780. GENTKT(WTKT); {GENERATE WINNING TICKET}
  781. WINNERVALID := TRUE;
  782. END; {PROC}
  783.  
  784.  
  785. {
  786. This procedure generates a screen display of the tickets including any valid
  787. winning draw in the ticket data set.
  788. }
  789.  
  790. PROCEDURE DISPTKTS;
  791.  
  792. VAR I, J, LINECOUNT, PCOUNT    :INTEGER;
  793.  
  794. BEGIN {PROC}
  795.  
  796. SCRNRESET;
  797. IF WinnerValid = TRUE THEN BEGIN  {display the winning ticket}
  798.    WRITELN ('THE WINNING TICKET IS:');
  799.    I := 0;
  800.    WRITE ('TKT NO. ',I:4,'::::');
  801.    FOR J := 1 TO NUMPIC DO WRITE (WTKT[J]:6);
  802.    WRITELN;
  803.    WRITELN;
  804.    WRITELN('YOUR TICKET PICKS ARE:');
  805.    WRITELN;
  806.    LINECOUNT := 7;
  807.    END
  808. ELSE
  809.    LINECOUNT := 0
  810. {ENDIF};
  811. PCOUNT := 0;
  812. FOR I := 1 TO NUMTKTS DO BEGIN           {print out the tickets}
  813.    WRITE ('TKT NO. ',I:4,'::::');
  814.    FOR J := 1 TO NUMPIC DO WRITE (TKTS[I,J]:6);
  815.    WRITELN;
  816.    PCOUNT := PCOUNT + 1;
  817.    LINECOUNT := LINECOUNT + 1;
  818.    IF ((PCOUNT MOD 5 = 0) AND (I < NUMTKTS)) THEN BEGIN {IF}
  819.       WRITELN;
  820.       PCOUNT := 0;
  821.       LINECOUNT := LINECOUNT + 1;
  822.       IF LINECOUNT > 18 THEN BEGIN {IF2} {screen full test}
  823.          GOTOXY(1,25);
  824.          HILITE;
  825.          CLREOL;
  826.          WRITE ('   ***  SCREEN FULL, PRESS ANY KEY TO CONTINUE   ***   ');
  827.          REPEAT UNTIL KEYPRESSED; {WAIT FOR KEYSTROKE}
  828.          READ (KBD);
  829.          SCRNRESET;
  830.          LINECOUNT := 0;
  831.          END
  832.       {END IF2};
  833.       END
  834.    {END IF};
  835. END {DO};
  836. GOTOXY(1,25);
  837. HILITE;
  838. CLREOL;
  839. WRITE ('   ***   END OF ENTRIES, PRESS ANY KEY TO CONTINUE   ***   ');
  840. REPEAT UNTIL KEYPRESSED; {WAIT FOR KEYSTROKE}
  841. READ (KBD);
  842. SCRNRESET;
  843. END {PROC};
  844.  
  845.  
  846. {
  847. This procedure is used to build a ticket entry from the keyboard.
  848. }
  849.  
  850. PROCEDURE BUILDTKT (VAR BTKT : TKT; VAR ABORT:BOOLEAN);
  851.  
  852. LABEL EXIT;
  853.  
  854. VAR
  855.     I, ENTRY, J                             : INTEGER;
  856.     DONE, DONE2, DONE3, DONE4               : BOOLEAN;
  857.     ANSWER                                  : CHAR;
  858.  
  859. BEGIN
  860. DONE := FALSE;
  861. ABORT := FALSE;
  862. REPEAT              {UNTIL VALID TICKET OR ABORT}
  863.    FOR I := 1 TO NUMPIC DO BEGIN
  864.       DONE2 := FALSE;
  865.       REPEAT                 {UNTIL VALID ENTRY OR ABORT}
  866.          GOTOXY(5,5);
  867.          CLREOL;
  868.          WRITE ('PICK NO.',I:2,' (0 TO QUIT)? ');
  869.          ENTRY := -1; {SET DEFAULT}
  870.          READLN (ENTRY);
  871.          IOCHECKA;
  872.          IF IOERR = TRUE THEN ENTRY := -1; {RESET DEFAULT ON I/O ERROR}
  873.          CASE ENTRY OF           {TEST ENTRY}
  874.          0           : BEGIN     {ABORT ENTRY}
  875.                        ABORT := TRUE;
  876.                        GOTO EXIT;
  877.                        END;
  878.          1..MAXNUM   : BEGIN     {VALID ENTRY}
  879.                        DONE2 := TRUE;
  880.                        BTKT[I] := ENTRY;
  881.                        END;
  882.          ELSE CHIRP
  883.          END{CASE};
  884.       UNTIL DONE2 = TRUE;
  885.       GOTOXY (2,10);   {SELECT ECHO}
  886.       CLREOL;
  887.       WRITE ('YOU HAVE PICKED:');
  888.       FOR J := 1 TO I DO WRITE (BTKT[J]:5);
  889.       WRITELN;
  890.    END{DO};
  891.    SORTPICK (BTKT);           {SORT ENTRYS}
  892.    DONE3 := TRUE;             {TEST FOR VALID TICKET}
  893.    FOR I := 1 TO (NUMPIC - 1) DO BEGIN
  894.       J := I + 1;
  895.       IF BTKT[I] = BTKT[J] THEN DONE3 := FALSE;      {= MEANS INVALID TICKET}
  896.    END{DO};
  897.    DONE4 := TRUE;
  898.    IF DONE3 = TRUE THEN BEGIN
  899.       CLRSCR; 
  900.       GOTOXY (2,10); {ECHO BACK SORTED CHOICE}
  901.       WRITE ('YOU HAVE PICKED:');
  902.       FOR J := 1 TO NUMPIC DO WRITE (BTKT[J]:5);
  903.       WRITELN;
  904.       GOTOXY (2,15);   {PLACE PROMPT ON SCREEN}
  905.       CLREOL;
  906.       WRITE ('IS THIS CORRECT (Y/N)? ');
  907.       REPEAT
  908.          ANSWER := 'Z'; {SET DEFAULT}
  909.          READ (KBD,ANSWER);
  910.          IOCHECKA;
  911.          IF IOERR = TRUE THEN ANSWER := 'Z'; {RESET DEFAULT ON I/O ERROR}
  912.          ANSWER := UPCASE(ANSWER);
  913.          IF (ANSWER IN ['Y','N']) = FALSE THEN BEEPBEEP(2);
  914.       UNTIL ANSWER IN ['Y','N'];
  915.       CLRSCR; {CLEAR ECHO AND PROMPT}
  916.       IF ANSWER = 'N' THEN DONE4 := FALSE;
  917.       END
  918.    ELSE BEGIN
  919.       GOTOXY(2,10);
  920.       CLREOL;
  921.       HILITE;
  922.       WRITE ('   ***   INVALID NUMBER SELECTION, RETRY   ***   ');
  923.       BEEPBEEP(3);
  924.       DELAY(1500);
  925.       LOLITE;
  926.       GOTOXY(2,10);
  927.       CLREOL;
  928.       DONE4 := FALSE;
  929.    END{IF};
  930.    DONE := DONE2 AND DONE3 AND DONE4;
  931. UNTIL DONE = TRUE;
  932. EXIT : END{PROC};
  933.  
  934. {
  935. This procedure will generate a random winning draw, or a manually entered
  936. winning draw.  It will also erase the winning draw.
  937. }
  938.  
  939.  
  940. PROCEDURE BUILDWIN;
  941.  
  942. VAR BTKT        : TKT;
  943.     ABORT       : BOOLEAN;
  944.     I           : INTEGER;
  945.     ANSWER      : CHAR;
  946.  
  947. BEGIN
  948. SCRNRESET;
  949. GOTOXY(1,3);
  950. WRITE ('PRESS ');
  951. HILITE;
  952. WRITE ('A');
  953. LOLITE;
  954. WRITELN ('FOR ABORT.');
  955. WRITE ('PRESS ');
  956. HILITE;
  957. WRITE ('R');
  958. LOLITE;
  959. WRITELN ('FOR RANDOM SELECTION OF WINNING DRAW.');
  960. WRITE ('PRESS ');
  961. HILITE;
  962. WRITE ('E');
  963. LOLITE;
  964. WRITELN ('TO ENTER WINNING DRAW FROM KEYBOARD.');
  965. WRITE ('PRESS ');
  966. HILITE;
  967. WRITE ('W');
  968. LOLITE;
  969. WRITELN ('TO ERASE WINNING DRAW.');
  970. GOTOXY(1,10);
  971. WRITE ('ENTER YOUR CHOICE (A,R,E,W)? ');
  972. REPEAT
  973.    ANSWER := 'Z'; {SET DEFAULT}
  974.    READ (KBD,ANSWER);
  975.    IOCHECKA;
  976.    IF IOERR = TRUE THEN ANSWER := 'Z'; {RESET DEFAULT ON I/O ERROR}
  977.    ANSWER := UPCASE (ANSWER);
  978.    IF (ANSWER IN ['A','R','E','W']) = FALSE THEN BEEP;
  979. UNTIL ANSWER IN ['A','R','E','W'];
  980. WRITELN (ANSWER);  {ECHO ACCEPTED ANSWER}
  981. DELAY(500); {LET THE USER SEE IT}
  982. CASE ANSWER OF
  983. 'R' : BEGIN
  984.          GENTKT(WTKT);
  985.          WINNERVALID := TRUE;
  986.       END;
  987. 'E' : BEGIN
  988.          SCRNRESET;
  989.          BUILDTKT(BTKT,ABORT);
  990.          IF ABORT = FALSE THEN BEGIN
  991.             WTKT := BTKT;
  992.             WINNERVALID := TRUE;
  993.          END{IF};
  994.       END;
  995. 'W' : BEGIN
  996.          FOR I := 1 TO NUMPIC DO WTKT[I] := MAXNUM; {FILL WITH NULL PATTERN}
  997.          WINNERVALID := FALSE;
  998.       END;
  999. END{CASE};
  1000. END{PROC};
  1001.  
  1002.  
  1003. {
  1004. This procedure is called from the main menu to build a series of tickets from
  1005. the keyboard.  It calls BUILDTKT repeatedly.
  1006. }
  1007.  
  1008. PROCEDURE ADDTKTS;
  1009.  
  1010. VAR BTKT         : TKT;
  1011.     ABORT        : BOOLEAN;
  1012.     GOMAX        : INTEGER;
  1013.  
  1014. BEGIN
  1015. SCRNRESET;
  1016. REPEAT
  1017.    GOMAX := TKTMAX - NUMTKTS;
  1018.    GOTOXY (2,2);
  1019.    CLREOL;
  1020.    WRITE ('YOU MAY ENTER UP TO',GOMAX:4,' ADDITIONAL ENTRIES.');
  1021.    BUILDTKT(BTKT,ABORT);
  1022.    IF ABORT = FALSE THEN BEGIN
  1023.       NUMTKTS := NUMTKTS + 1;
  1024.       TKTS[NUMTKTS] := BTKT;
  1025.    END{IF};
  1026. UNTIL ((ABORT = TRUE) OR (NUMTKTS >= TKTMAX))
  1027. END{PROC};
  1028.  
  1029.  
  1030. {
  1031. This procedure will add a number of random tickets to the data set based on
  1032. input from the keyboard.  Procedure GENTKT is called to generate each ticket.
  1033. }
  1034.  
  1035. PROCEDURE ADDRANDUM;
  1036.  
  1037. VAR MAXGO, KOUNT, I           : INTEGER;
  1038.     RNDTKT                    : TKT;
  1039.     DONE                      : BOOLEAN;
  1040.  
  1041. BEGIN
  1042. MAXGO := TKTMAX - NUMTKTS;
  1043. SCRNRESET;
  1044. GOTOXY (5,2);
  1045. WRITELN ('YOU MAY REQUEST UP TO',MAXGO:4,' TICKETS.');
  1046. DONE := FALSE;
  1047. REPEAT
  1048.    GOTOXY (5,5);
  1049.    CLREOL;
  1050.    WRITE ('HOW MANY TICKETS? ');
  1051.    KOUNT := -1; {SET DEFAULT}
  1052.    READLN (KOUNT);
  1053.    IOCHECKA;
  1054.    IF IOERR = TRUE THEN KOUNT := -1; {RESET DEFAULT ON I/O ERROR}
  1055.    IF KOUNT = 0 THEN DONE:=TRUE;                     {ABORT}
  1056.    IF ((KOUNT > 0) AND (KOUNT <= MAXGO)) THEN BEGIN  {VALID INPUT}
  1057.       FOR I := 1 TO KOUNT DO BEGIN                   {BUILD THE TICKETS LOOP}
  1058.          GENTKT(RNDTKT);                             {BUILD SINGLE TICKET}
  1059.          NUMTKTS := NUMTKTS + 1;
  1060.          TKTS[NUMTKTS] := RNDTKT;
  1061.       END{DO};
  1062.       DONE := TRUE;        {FINISHED WITH TASK}
  1063.       END
  1064.    ELSE BEEP {INVALID OR DEFAULT REPLY}
  1065.    {ENDIF};
  1066. UNTIL DONE = TRUE;
  1067. END{PROC};
  1068.  
  1069.  
  1070. {
  1071. This procedure removes a ticket from the ticket set.
  1072. }
  1073.  
  1074. PROCEDURE DROPTKTS;
  1075.  
  1076. VAR
  1077.    ANSWER              : CHAR;
  1078.    I, J, K             : INTEGER;
  1079.  
  1080. BEGIN
  1081. SCRNRESET;
  1082.  
  1083.                     {RED ON WHITE TOP BANNER}
  1084.  
  1085. TEXTCOLOR (RED);
  1086. TEXTBACKGROUND (WHITE);
  1087. CLREOL;
  1088. WRITELN;
  1089. CLREOL;
  1090. WRITELN ('   !!!   WARNING   !!!  REMAINDER OF SET WILL BE RENUMBERED!');
  1091. CLREOL;
  1092.  
  1093.                     {RETURN TO NORMAL}
  1094.  
  1095. LOLITE;
  1096. REPEAT
  1097.    GOTOXY (5,9);
  1098.    CLREOL;
  1099.    WRITE ('DO YOU WISH TO PROCEDE (Y/N)? ');
  1100.    ANSWER := 'Z'; {SET DEFAULT INVALID ANSWER}
  1101.    READ (KBD,ANSWER);
  1102.    IOCHECKA;
  1103.    IF IOERR = TRUE THEN ANSWER := 'Z'; {RESET DEFAULT ON I/O ERROR}
  1104.    ANSWER := UPCASE(ANSWER);
  1105.    IF NOT(ANSWER IN ['Y','N']) THEN BEEPBEEP(2);
  1106. UNTIL ANSWER IN ['Y','N'];
  1107. WRITE (ANSWER); {ECHO ACCEPTED ANSWER}
  1108. IF ANSWER = 'Y' THEN BEGIN
  1109.    GOTOXY (5,12);
  1110.    WRITELN ('THERE ARE',NUMTKTS:4,' TICKETS IN THE SET.');
  1111.    REPEAT
  1112.       GOTOXY (2,15);
  1113.       CLREOL;
  1114.       WRITE ('TICKET NUMBER TO BE DELETED? ');
  1115.       I := NUMTKTS + 1; {SET DEFAULT}
  1116.       READLN (I);
  1117.       IOCHECKA;
  1118.       IF IOERR = TRUE THEN I:= NUMTKTS + 1; {RESET DEFAULT ON I/O ERROR}
  1119.       IF NOT(I IN [1..NUMTKTS]) THEN BEEP;
  1120.    UNTIL I IN [1..NUMTKTS];      {VALID INPUT TEST}
  1121.    IF I <> NUMTKTS THEN BEGIN                {DROP THE STACK}
  1122.       FOR J := I TO (NUMTKTS - 1) DO BEGIN
  1123.          K := J + 1;
  1124.          TKTS[J] := TKTS[K];
  1125.       END{DO};
  1126.    END{IF};
  1127.    FOR J := 1 TO NUMPIC DO TKTS[NUMTKTS,J] := MAXNUM; {ERASE TOP OF STACK}
  1128.    NUMTKTS := NUMTKTS - 1; {DECREASE TOP OF DATA POINTER}
  1129. END{IF};
  1130. SCRNRESET;
  1131. END{PROC};
  1132.  
  1133.  
  1134. {
  1135. THIS PROCEDURE INSERTS A TICKET INTO THE SET
  1136. }
  1137.  
  1138. PROCEDURE INSERTTKT;
  1139.  
  1140. LABEL
  1141.     EXIT;
  1142.  
  1143. VAR
  1144.     DONE, ABORT                          : BOOLEAN;
  1145.     INSRTPOINT, OLDTOP, I                : INTEGER;
  1146.     BTKT                                 : TKT;
  1147.  
  1148. BEGIN
  1149. DONE := FALSE;
  1150. REPEAT
  1151.   SCRNRESET;
  1152.   WRITELN;
  1153.   WRITELN ('ENTER TICKET NUMBER FROM 1 TO ',NUMTKTS);
  1154.   WRITE (' OR ENTER 0 TO EXIT.   ');
  1155.   INSRTPOINT := -1; {SET DEFAULT INVALID VALUE}
  1156.   READLN (INSRTPOINT);
  1157.   IOCHECKA;
  1158.   IF IOERR = TRUE THEN INSRTPOINT := -1; {RESET TO DEFAULT VALUE}
  1159.   IF (INSRTPOINT IN [0..NUMTKTS]) THEN
  1160.     DONE := TRUE
  1161.   ELSE BEGIN
  1162.     ALERT1 (1);
  1163.     DELAY (1000);
  1164.   END {IF};
  1165. UNTIL DONE = TRUE;
  1166. IF INSRTPOINT = 0 THEN GOTO EXIT;
  1167. BUILDTKT (BTKT,ABORT);
  1168. IF ABORT = FALSE THEN BEGIN
  1169.   OLDTOP := NUMTKTS;
  1170.   NUMTKTS := NUMTKTS + 1;
  1171.   FOR I:= OLDTOP DOWNTO INSRTPOINT DO BEGIN
  1172.     TKTS[I+1] := TKTS[I];
  1173.   END;
  1174.   TKTS[INSRTPOINT] := BTKT
  1175. END {IF};
  1176. EXIT:
  1177. END {PROC};
  1178.  
  1179.  
  1180. {
  1181. THIS PROCEDURE REPLACES ONE TICKET IN THE SET WITH ANOTHER ENTERED FROM THE
  1182. KEYBOARD.
  1183. }
  1184.  
  1185. PROCEDURE REPLACETKTS;
  1186.  
  1187. LABEL
  1188.     LOOP;
  1189.  
  1190. VAR
  1191.     SELECT                              : INTEGER;
  1192.     DONE, ABORT                         : BOOLEAN;
  1193.     BTKT                                : TKT;
  1194.  
  1195. BEGIN
  1196. DONE := FALSE;
  1197. REPEAT
  1198.   SCRNRESET;
  1199.   WRITELN;
  1200.   WRITELN ('ENTER TICKET NO. FROM 1 TO ',NUMTKTS);
  1201.   WRITE   (' OR ENTER 0 TO ABORT.   ');
  1202.   SELECT := -1; {SET DEFAULT VALUE}
  1203.   BEEP;
  1204.   READLN (SELECT);
  1205.   IOCHECKA;
  1206.   IF IOERR = TRUE THEN BEGIN
  1207.     ALERT1 (1);
  1208.     DELAY (1000);
  1209.     GOTO LOOP;
  1210.   END {IF};
  1211.   IF SELECT = 0 THEN BEGIN
  1212.     DONE := TRUE;
  1213.     GOTO LOOP;
  1214.   END {IF};
  1215.   IF ((SELECT >= 1) AND (SELECT <= NUMTKTS)) THEN BEGIN
  1216.     BUILDTKT(BTKT,ABORT);
  1217.     IF ABORT = FALSE THEN TKTS[SELECT] := BTKT;
  1218.     DONE := TRUE; END
  1219.   ELSE BEGIN
  1220.     ALERT1 (1);
  1221.     DELAY (1000);
  1222.   END {IF};
  1223. LOOP:
  1224. UNTIL DONE = TRUE;
  1225. END {PROC};
  1226.  
  1227.  
  1228. {
  1229. THIS PROCEDURE DISPLAYS THE EDIT MENU AND EXECUTES THE APPROPRIATE SUBROUTINES
  1230. TO EDIT EXISTING ENTRIES.
  1231. }
  1232.  
  1233. PROCEDURE EDITMENU;
  1234.  
  1235. LABEL
  1236.     EXIT, LOOP;
  1237.  
  1238. VAR
  1239.     DONE                                  : BOOLEAN;
  1240.     SELECTION                             : INTEGER;
  1241.  
  1242. BEGIN
  1243. DONE := FALSE;
  1244. REPEAT
  1245.   SCRNRESET;
  1246.   IF NUMTKTS < 1 THEN GOTO EXIT;
  1247.   GOTOXY (35,2);
  1248.   WRITELN ('EDIT MENU');
  1249.   WRITELN ;
  1250.   WRITELN ('0.  EXIT THIS MENU.');
  1251.   IF NUMTKTS < TKTMAX THEN
  1252.     WRITELN ('1.  INSET TICKET INTO SET.')
  1253.   ELSE
  1254.     WRITELN
  1255.   {END IF};
  1256.   WRITELN ('2.  DELETE TICKET FROM SET.');
  1257.   WRITELN ('3.  REPLACE TICKET IN SET.');
  1258.   WRITELN;
  1259.   WRITE ('ENTER YOUR SELECTION.  ');
  1260.   SELECTION := -1; {SET DEFAULT INVALID}
  1261.   BEEP;
  1262.   READLN (SELECTION);
  1263.   IOCHECKA;
  1264.   IF IOERR = TRUE THEN SELECTION := -1; {RESTORE DEFAULT VALUE}
  1265.   IF NOT(SELECTION IN [0..3]) THEN BEGIN
  1266.     GOTOXY (1,22);
  1267.     WRITE ('ERROR TRY AGAIN');
  1268.     HILOTONE(2);
  1269.     DELAY (1000);
  1270.     GOTO LOOP;
  1271.   END {IF};
  1272.   CASE SELECTION OF
  1273.   0 : DONE := TRUE;
  1274.   1 : BEGIN
  1275.         INSERTTKT;
  1276.         IF AUTODISP = Y THEN DISPTKTS;
  1277.       END;
  1278.   2 : BEGIN
  1279.         DROPTKTS;
  1280.         IF AUTODISP = Y THEN DISPTKTS;
  1281.       END;
  1282.   3 : BEGIN
  1283.         REPLACETKTS;
  1284.         IF AUTODISP = Y THEN DISPTKTS;
  1285.       END;
  1286.   END {CASE};
  1287. LOOP :
  1288. UNTIL DONE = TRUE;
  1289. EXIT :
  1290. END {PROC};
  1291.  
  1292.  
  1293. {opening display, copyright notice and music}
  1294.  
  1295. PROCEDURE BANNER;
  1296.  
  1297. BEGIN
  1298. HILITE;
  1299. ClrScr;
  1300. GoToXY (28,5);
  1301. WRITELN ('***   LOTTERY FUN   ***');
  1302. GoToXY (31,8);
  1303. WRITELN ('BY KARL W. EHRLICH');
  1304. GOTOXY (1,14);
  1305. LOLITE;
  1306. WRITELN ('  COPYRIGHT (c) AUGUST 1986     ');
  1307. WRITELN ('           AND OCTOBER 1986     ');
  1308. WRITELN ('                                ');
  1309. WRITELN ('  ALL RIGHTS RESERVED           ');
  1310. HILITE;
  1311. WRITELN;
  1312. WRITELN ('RELEASE NUMBER: ',RELNO:6:3);
  1313. HILOTONE (3);
  1314. DELAY (5000);
  1315. END;
  1316.  
  1317.  
  1318. {
  1319. This procedure take an input file name and verifies that it is either a
  1320. standard file name, or a drive:filename without an extension.  If the
  1321. file name is valid the extension .lfd is added and fault is set to false.
  1322.  
  1323. In case of error fault is set to true and the original name is unchanged.
  1324. }
  1325.  
  1326.  
  1327. PROCEDURE VFNAME (VAR FILEB : FILENAME; VAR FAULT : BOOLEAN);
  1328.  
  1329. VAR
  1330.     FILEA                          : FILENAME;
  1331.     I                              : INTEGER;
  1332.  
  1333. BEGIN
  1334. FILEA := FILEB;
  1335. FAULT := FALSE;
  1336.  
  1337. {CONVERT TO UPPER CASE LETTERS}
  1338.  
  1339. FOR I := 1 TO LENGTH(FILEA) DO FILEA[I] := UPCASE (FILEA[I]);
  1340.  
  1341. {STRIP LEADING BLANKS}
  1342.  
  1343. WHILE ((LENGTH (FILEA) > 0) AND (FILEA[1] = ' ')) DO DELETE (FILEA,1,1);
  1344.  
  1345. {STRIP TRAILING BLANKS}
  1346.  
  1347. WHILE ((LENGTH (FILEA) > 0) AND (FILEA[LENGTH (FILEA)] = ' ')) DO
  1348.      DELETE (FILEA, (LENGTH (FILEA)), 1);
  1349.  
  1350. {CHECK FOR VALID REMAINING CHARACTERS BASED ON LENGTH}
  1351.  
  1352. CASE LENGTH (FILEA) OF
  1353. 0     : FAULT := TRUE;
  1354. 9,10  : BEGIN {BRANCH}
  1355.         IF ((FILEA[1] IN ['A'..'F']) AND (FILEA[2] = ':')) THEN BEGIN
  1356.           IF NOT (FILEA[3] IN ['A'..'Z']) THEN FAULT := TRUE
  1357.           ELSE BEGIN
  1358.             FOR I := 3 TO LENGTH (FILEA) DO BEGIN
  1359.               IF NOT (FILEA[I] IN ['A'..'Z','0'..'9']) THEN FAULT := TRUE;
  1360.             END {DO};
  1361.           END {IF};
  1362.           END
  1363.         ELSE FAULT := TRUE
  1364.         {END IF};
  1365.         END {BRANCH};
  1366. 1..8  : BEGIN {BRANCH}
  1367.         IF ((FILEA[1] IN ['A'..'F']) AND (FILEA[2] = ':') AND
  1368.              (LENGTH (FILEA) > 2)) THEN BEGIN
  1369.           IF NOT (FILEA[3] IN ['A'..'Z']) THEN FAULT := TRUE
  1370.           ELSE BEGIN
  1371.             FOR I := 3 TO LENGTH (FILEA) DO BEGIN
  1372.               IF NOT (FILEA[I] IN ['A'..'Z','0'..'9']) THEN FAULT := TRUE;
  1373.             END {DO};
  1374.           END {IF};
  1375.           END
  1376.         ELSE BEGIN
  1377.           IF NOT (FILEA[1] IN ['A'..'Z']) THEN FAULT := TRUE
  1378.           ELSE BEGIN
  1379.             FOR I := 1 TO LENGTH (FILEA) DO BEGIN
  1380.               IF NOT (FILEA[I] IN ['A'..'Z','0'..'9']) THEN FAULT := TRUE;
  1381.             END {DO};
  1382.           END {IF};
  1383.         END {IF};
  1384.         END {BRANCH};
  1385. ELSE    FAULT := TRUE
  1386. END {CASE};
  1387. IF FAULT = FALSE THEN FILEB := FILEA + '.LFD';
  1388. END {PROC};
  1389.  
  1390.  
  1391. {THIS PROCEDURE RENAMES A FILE FOR DATA.}
  1392.  
  1393. PROCEDURE RENFILE;
  1394.  
  1395. LABEL
  1396.      EXIT;
  1397.  
  1398. VAR
  1399.      FOUND1, FOUND2, FAULT                  : BOOLEAN;
  1400.      FILE1, FILE11, FILE2, FILE21           : FILENAME;
  1401.      OLDFILE, NEWFILE                       : TEXT;
  1402.      IOVAR, IOVAR2                          : INTEGER;
  1403. BEGIN
  1404. SCRNRESET;
  1405. GOTOXY (1,6);
  1406. WRITELN ('OR PRESS RETURN TO EXIT');
  1407. REPEAT
  1408.   GOTOXY (1,4);
  1409.   CLREOL;
  1410.   WRITE ('NAME OF FILE TO BE RENAMED? ');
  1411.   READLN (FILE1);
  1412.   IOCHECKA;
  1413.   IF IOERR = TRUE THEN FAULT := TRUE
  1414.   ELSE BEGIN
  1415.     IF FILE1 = '' THEN GOTO EXIT;
  1416.     FILE11 := FILE1;
  1417.     VFNAME (FILE11, FAULT);
  1418.   END{IF};
  1419. UNTIL FAULT = FALSE;
  1420. GOTOXY (1,12);
  1421. WRITELN ('OR PRESS RETURN TO EXIT');
  1422. REPEAT
  1423.   GOTOXY (1,10);
  1424.   CLREOL;
  1425.   WRITE ('NEW FILE NAME? ');
  1426.   READLN (FILE2);
  1427.   IOCHECKA;
  1428.   IF IOERR = TRUE THEN FAULT := TRUE
  1429.   ELSE BEGIN
  1430.     IF FILE2 = '' THEN GOTO EXIT;
  1431.     FILE21 := FILE2;
  1432.     VFNAME (FILE21, FAULT);
  1433.   END{IF};
  1434. UNTIL FAULT = FALSE;
  1435. ASSIGN (OLDFILE,FILE11);
  1436. RESET (OLDFILE) {CHECK TO SEE FILE EXISTS.};
  1437. IOVAR := IORESULT;
  1438. IF IOVAR = 0 THEN BEGIN {FILE FOUND}
  1439.   CLOSE (OLDFILE);
  1440.   ASSIGN (NEWFILE, FILE21);
  1441.   RESET (NEWFILE) {CHECK TO SEE THAT FILE DOESN'T EXIST};
  1442.   IOVAR2 := IORESULT;
  1443.   IF IOVAR2 IN [$01,$02] THEN BEGIN
  1444.     RENAME (OLDFILE, FILE21);
  1445.     IOCHECK;
  1446.     IF IOERR = TRUE THEN BEGIN
  1447.       WRITELN ('RENAME ABORTED',^G);
  1448.       DELAY (1000);
  1449.       GOTO EXIT;
  1450.     END{IF};
  1451.     END
  1452.   ELSE BEGIN
  1453.     GOTOXY (1,20);
  1454.     IF IOVAR2 = 0 THEN WRITELN ('FILE > ',FILE2,' < ALREADY EXISTS')
  1455.     ELSE WRITELN ('I/O ERROR WITH > ',FILE2,' <',IOVAR2:10)
  1456.     {ENDIF};
  1457.     WRITELN ('RENAME ABORTED',^G);
  1458.     DELAY (1000);
  1459.     GOTO EXIT;
  1460.   END{IF};
  1461.   END
  1462. ELSE BEGIN {FILE NOT FOUND}
  1463.   GOTOXY (1,20);
  1464.   IF IOVAR IN [1,2] THEN WRITELN ('FILE > ',FILE1,' < NOT FOUND')
  1465.   ELSE WRITELN ('I/O ERROR WITH > ',FILE1,' <',IOVAR:10)
  1466.   {ENDIF};
  1467.   WRITELN ('RENAME ABORTED',^G);
  1468.   DELAY (1000);
  1469. END{IF};
  1470. EXIT:
  1471. END {PROC};
  1472.  
  1473.  
  1474. {
  1475. This procedure requests a data file name for deletion.  Data files all have
  1476. the extension .LFD.  The operator only puts in the file name.  The file name
  1477. is checked for proper input I/O and then to see if it fits the format of name
  1478. or X:name.  If the file name passes these checks an attempt is made to erase
  1479. the file and an I/O check is performed.
  1480. }
  1481.  
  1482. PROCEDURE DROPFILE;
  1483.  
  1484. LABEL
  1485.      EXIT;
  1486.  
  1487. VAR
  1488.      FILEA                          : FILENAME;
  1489.      FAULT                          : BOOLEAN;
  1490.      ERASEFILE                      : TEXT;
  1491.  
  1492. BEGIN
  1493. SCRNRESET;
  1494. GOTOXY (1,7);
  1495. WRITELN ('OR PRESS RETURN TO EXIT');
  1496. REPEAT {ENTER FILE NAME}
  1497.    GOTOXY (1,5);
  1498.    CLREOL;
  1499.    WRITE ('NAME OF DATA FILE TO BE ERASED? ');
  1500.    READLN (FILEA);
  1501.    IOCHECKA;
  1502.    IF IOERR = TRUE THEN FAULT := TRUE {bad input, cause a retry}
  1503.    ELSE BEGIN
  1504.      IF FILEA = '' THEN GOTO EXIT; {test for abort}
  1505.      VFNAME (FILEA, FAULT); {verify file name and append suffix if valid
  1506.                              else cause a retry}
  1507.    END{IF};
  1508. UNTIL FAULT = FALSE;
  1509. ASSIGN (ERASEFILE, FILEA);   {try to locate the file}
  1510. ERASE (ERASEFILE);         {erase the file}
  1511. IOCHECK;
  1512. EXIT :
  1513. END {PROC};
  1514.  
  1515.  
  1516. {
  1517. THIS PROCEDURE READS IN THE TICKET DATA FROM A DISK DATA FILE.
  1518. }
  1519.  
  1520. PROCEDURE RDISKTKTS;
  1521.  
  1522. LABEL
  1523.      PEXIT;
  1524.  
  1525. TYPE
  1526.      FILENAME = STRING[32];
  1527.  
  1528.  
  1529. VAR
  1530.      I, IOVAL                               : INTEGER;
  1531.      FOUND, FAULT                           : BOOLEAN;
  1532.      FILEA                                  : FILENAME;
  1533.  
  1534. BEGIN
  1535. SCRNRESET;
  1536. FOUND := FALSE;
  1537. GOTOXY (1,3);
  1538. WRITELN;
  1539. WRITELN ('OR PRESS RETURN TO EXIT.');
  1540. WRITELN;
  1541. WRITELN ('WARNING!  CURRENT TICKET SET WILL BE LOST!');
  1542. REPEAT {UNTIL IO GOOD}
  1543.    GOTOXY (1,2);
  1544.    CLREOL;
  1545.    WRITE ('NAME OF FILE TO READ? ');
  1546.    READLN (FILEA);
  1547.    IOCHECKA;
  1548.    IF IOERR = TRUE THEN FAULT := TRUE
  1549.    ELSE BEGIN
  1550.       IF FILEA = '' THEN GOTO PEXIT;
  1551.       VFNAME (FILEA, FAULT);
  1552.    END {IF};
  1553. UNTIL FAULT = FALSE;
  1554. ASSIGN (INFILE,FILEA);
  1555. RESET (INFILE);
  1556. IOCHECK;
  1557. IF IOERR = TRUE THEN GOTO PEXIT;
  1558. FOUND := TRUE;
  1559. REINIT;   {CLEAR AWAY OLD TICKETS}
  1560. SEEK (INFILE,0);  {ASSURE STARTING POSITION}
  1561. READ (INFILE,TKTREC);
  1562. IOCHECK;
  1563. IF IOERR = TRUE THEN GOTO PEXIT; {BOMB & OUT}
  1564. WTKT := TKTREC.TICKET;
  1565. IF WTKT[1] < MAXNUM THEN WINNERVALID := TRUE;
  1566. WHILE NOT(EOF(INFILE)) DO BEGIN
  1567.    READ (INFILE,TKTREC); {READ IN A TICKET VALUE}
  1568.    IOCHECK;
  1569.    IF IOERR = TRUE THEN GOTO PEXIT; {BOMB & OUT}
  1570.    NUMTKTS := NUMTKTS + 1;
  1571.    IF NUMTKTS > TKTMAX THEN GOTO PEXIT; {FILE TOO LARGE}
  1572.    TKTS[NUMTKTS] := TKTREC.TICKET;  {STORE IN THE ARRAY}
  1573. END{WHILE};
  1574. PEXIT : IF FOUND = TRUE THEN CLOSE(INFILE);  {HOUSEKEEPING SHUTDOWN FILE}
  1575. END {PROC};
  1576.  
  1577.  
  1578. {
  1579. THIS PROCEDURE WRITES TICKET DATA TO DISK.  ONLY DATA FOR VALID TICKETS
  1580. AND THE WINNER ARE WRITTEN TO THE DISK.
  1581. }
  1582.  
  1583. PROCEDURE WDiskTkts;
  1584.  
  1585. LABEL
  1586.     EXIT;
  1587.  
  1588. TYPE
  1589.     FILENAME = STRING[32];
  1590.  
  1591. VAR I, Ioval1                           : INTEGER;
  1592.     Found, Open, IOErr1, FAULT          : BOOLEAN;
  1593.     CH                                  : CHAR;
  1594.     FILEA                               : FILENAME;
  1595.  
  1596. BEGIN
  1597. SCRNRESET;
  1598. Found := FALSE;
  1599. GOTOXY (1,3);
  1600. WRITELN ('OR PRESS RETURN TO EXIT');
  1601. REPEAT {UNTIL FILE TO WRITE OR ABORT}
  1602.    GOTOXY (1,2);
  1603.    CLREOL;
  1604.    WRITE ('NAME OF FILE TO WRITE? ');
  1605.    READLN (FileA);
  1606.    IOCHECKA;
  1607.    IF IOERR = TRUE THEN FAULT := TRUE  {BAD INPUT}
  1608.    ELSE BEGIN
  1609.       IF FILEA = '' THEN GOTO EXIT;    {ABORT CHECK}
  1610.       VFNAME (FILEA, FAULT);           {VERIFY FILE NAME OR FAULT:=TRUE}
  1611.    END {IF};
  1612. UNTIL FAULT = FALSE; {VALID INPUT TEST}
  1613. ASSIGN (OutFile,FileA);
  1614. RESET (OutFile); {TEST FOR FILE FOUND BY OPENING FOR READ}
  1615. IOCHECKA;
  1616. IF IOERR = FALSE THEN BEGIN {FILE FOUND}
  1617.    CLOSE (OutFile);     {CLOSE IT SO IT CAN BE REOPENED FOR WRITITNG}
  1618.    GOTOXY (1,6); {ALERT & PROMPT}
  1619.    HILITE;
  1620.    WRITELN ('FILE> ',FileA,' ALREADY EXISTS.');
  1621.    WRITELN;
  1622.    WRITE (' !!! WARNING !!!  ');
  1623.    WRITELN ('OVERWRITE WILL WIPE OUT WHATEVER IS IN THE FILE!');
  1624.    WRITELN;
  1625.    REPEAT          {HUMAN DECISION REQUIRED}
  1626.       GOTOXY (1,12);
  1627.       CLREOL;
  1628.       WRITE ('OVERWRITE (Y/N)? ');
  1629.       BEEPBEEP (3);
  1630.       CH := 'A'; {SET DEFAULT FOR RECYCLE}
  1631.       READ (KBD,CH);
  1632.       IOCHECKA;
  1633.       IF IOERR = TRUE THEN CH := 'A'; {RESET DEFAULT ON I/O FILE ERROR}
  1634.       CH := UPCASE(CH);
  1635.    UNTIL CH IN ['Y','N'];
  1636.    WRITELN (CH); {ECHO}
  1637.    DELAY (500);              {SHOW THE CHOICE}
  1638.    IF CH = 'N' THEN GOTO EXIT;
  1639.    END
  1640. ELSE BEGIN     {FILE NOT SUCCESSFULLY FOUND}
  1641.    IF Ioval > $02 THEN BEGIN {PROBLEM OTHER THAN FILE NOT FOUND}
  1642.       HILITE;
  1643.       GOTOXY (1,9);
  1644.       WRITELN ('I/O ERROR NO. ',Ioval1,' HAS OCCURRED');
  1645.       WRITE (^G);
  1646.       REPEAT UNTIL KEYPRESSED;
  1647.       READ (KBD);
  1648.       GOTO EXIT;
  1649.    END{IF};
  1650. END{IF};
  1651. ASSIGN (OUTFILE,FILEA);
  1652. REWRITE (OutFile);
  1653. IOCheck;
  1654. IF IOERR = TRUE THEN GOTO EXIT;
  1655. Open := TRUE;
  1656. SEEK (OutFile,0); {ASSURE FIRST RECORD}
  1657. IOCheck;
  1658. IF IOERR = TRUE THEN GOTO EXIT;  {BOMB & OUT}
  1659. TKTREC.TICKET := WTKT;
  1660. WRITE (OutFile,TKTREC);
  1661. IOCheck;
  1662. IF IOERR = TRUE THEN GOTO EXIT;  {BOMB & OUT}
  1663. FOR I := 1 TO NUMTKTS DO BEGIN
  1664.    TKTREC.TICKET := TKTS[I];
  1665.    WRITE (OutFile,TKTREC);
  1666.    IOCheck;
  1667.    IF IOERR = TRUE THEN GOTO EXIT;  {BOMB & OUT}
  1668. END{DO};
  1669. EXIT : IF Open = TRUE THEN CLOSE(OutFile);
  1670. END{PROC};
  1671.  
  1672.  
  1673. {
  1674. THIS PROCEDURE PRINTS OUT THE TICKET SET WITH APPROPRIATE PAUSE LOGIC
  1675. }
  1676.  
  1677. Procedure PrintTickets;
  1678.  
  1679. CONST Space=' ';
  1680.  
  1681. Var StartTktNo, EndTktNo, TktsRem, PrintCount, GroupCount,
  1682.     ColGroups, I, J, K, LCount                             : INTEGER;
  1683.  
  1684.     LastPage                                               : Boolean;
  1685.  
  1686. BEGIN
  1687. HILITE;
  1688. CLRSCR;
  1689. WRITELN ('SET PRINTER TO TOP OF FORM AND ON LINE,');
  1690. WRITELN;
  1691. WRITELN ('THEN PRESS ANY KEY TO CONTINUE PRINTING.');
  1692. BEEPBEEP (3);
  1693. REPEAT UNTIL KEYPRESSED;
  1694. READ (KBD);
  1695. StartTktNo := 1;
  1696. TktsRem := NumTkts;
  1697. LastPage := TRUE;
  1698. WHILE TktsRem > 0 do BEGIN
  1699.    IF TktsRem > 80 THEN BEGIN
  1700.       PrintCount := 40;
  1701.       EndTktNo := StartTktNo + 79;
  1702.       LastPage := FALSE;
  1703.       END
  1704.    ELSE BEGIN
  1705.       GroupCount := TktsRem DIV 5;
  1706.       IF (TktsRem MOD 5) > 0 THEN GroupCount := GroupCount +1;
  1707.       ColGroups := (GroupCount DIV 2) + (GroupCount MOD 2);
  1708.       PrintCount := ColGroups * 5;
  1709.       EndTktNo := NUMTKTS;
  1710.       LastPage := TRUE;
  1711.    END {IF};
  1712.    FOR I := 1 TO 6 DO WRITELN (LST);
  1713.    FOR I := 1 TO 33 DO WRITE (LST,Space);
  1714.    WRITELN (LST,'TICKETS PICKED');
  1715.    WRITELN (LST);
  1716.    WRITE (LST,'TICKET     NUMBERS');
  1717.    FOR I := 1 TO 23 DO WRITE (LST,Space);
  1718.    WRITELN (LST,'TICKET     NUMBERS');
  1719.    WRITE (LST,'NUMBER      PICKED');
  1720.    FOR I := 1 TO 23 DO WRITE (LST,Space);
  1721.    WRITELN (LST,'NUMBER      PICKED');
  1722.    WRITELN (LST);
  1723.    LCount := 0;
  1724.    FOR I:= StartTktNo TO (StartTktNo + PrintCount - 1) DO BEGIN
  1725.       J := I + PrintCount;
  1726.       WRITE (LST,I:3);
  1727.       WRITE (LST,TKTS[I,1]:8);
  1728.       FOR K := 2 TO Numpic DO WRITE (LST,TKTS[I,K]:4);
  1729.       IF J > NumTkts THEN WRITELN(LST)
  1730.       ELSE BEGIN
  1731.          WRITE (LST,J:13);
  1732.          WRITE (LST,TKTS[J,1]:8);
  1733.          FOR K := 2 TO Numpic DO WRITE (LST,TKTS[J,K]:4);
  1734.          WRITELN (LST);
  1735.       END{IF};
  1736.       LCount := LCount + 1;
  1737.       IF ((LCount +1) MOD 6) = 0 THEN BEGIN
  1738.          WRITELN (LST);
  1739.          LCount := LCount + 1;
  1740.       END{IF};
  1741.    END{DO};
  1742.    IF LastPage = FALSE THEN BEGIN
  1743.       WRITE (LST,^L);      {TOP OF PAGE}
  1744.       StartTktNo := EndTktNo + 1;
  1745.       TktsRem := NumTkts - EndTktNo;
  1746.       END
  1747.    ELSE BEGIN
  1748.       TktsRem := 0;
  1749.    END{IF};
  1750. END{WHILE};
  1751. IF WINNERVALID = TRUE THEN BEGIN
  1752.    IF LCount > 43 THEN BEGIN     {CHECK FOR ENOUGH PAGE REMAINING}
  1753.       WRITE (LST,^L);  {EJECT PAGE}
  1754.       FOR I := 1 TO 6 DO WRITELN (LST);
  1755.       WRITELN;
  1756.    END{IF};
  1757.    WRITELN (LST);
  1758.    WRITELN (LST);
  1759.    FOR I := 1 TO 24 DO WRITE (LST,Space);
  1760.    WRITELN (LST,'THE WINNING LOTTO NUMBERS WERE:');
  1761.    WRITELN (LST);
  1762.    FOR I := 1 TO 24 DO WRITE (LST,Space);
  1763.    FOR I := 1 TO Numpic DO WRITE (LST,WTKT[I]:4);
  1764. END{IF};
  1765. WRITE (LST,^L); {EJECT PAGE}
  1766. END{PROC};
  1767.  
  1768.  
  1769. {
  1770. THIS PROCEDURE ACTS AS THE MAIN MENU AND TASK SCHEDULER FOR THE LOTTERY
  1771. PROGRAM.  IT SCHEDULES ALL EXECUTION EXCEPT FOR PROGRAM INITIALIZATION AND
  1772. TERMINATION.
  1773. }
  1774.  
  1775. PROCEDURE MAINMENU;
  1776.  
  1777. LABEL
  1778.       ENDLOOP;
  1779.  
  1780. CONST
  1781.       MAXCHOICE = 15;
  1782.       QUESTLINE = 19;
  1783.  
  1784. TYPE
  1785.       CHOICETYPE = 0..MAXCHOICE;
  1786.       CHOICESET = SET OF 0..MAXCHOICE;
  1787. VAR
  1788.       DONE                                               : BOOLEAN;
  1789.       REPLYVALID                                         : CHOICESET;
  1790.       SELECTION                                          : CHOICETYPE;
  1791.  
  1792. BEGIN
  1793. DONE := FALSE;
  1794. REPEAT
  1795.  
  1796.      { This procedure generates the main selection menu for the program.}
  1797.  
  1798.    SCRNRESET;
  1799.    REPLYVALID := [0..2,7,11..15];
  1800.    HILITE;
  1801.    GoToXY (35,2);
  1802.    WRITELN ('MAIN MENU');
  1803.    WINDOW (3,4,78,23);
  1804.    ClrScr;
  1805.    WRITELN;
  1806.    WRITELN (' 0.  EXIT PROGRAM');
  1807.    WRITELN (' 1.  READ TICKET SET FROM DISK');
  1808.    WRITELN (' 2.  START NEW TICKET SET');
  1809.    IF (NUMTKTS < TKTMAX) THEN BEGIN
  1810.       REPLYVALID := REPLYVALID + [3,4];
  1811.       WRITELN (' 3.  ENTER MORE TICKETS INTO SET');
  1812.       WRITELN (' 4.  ADD RANDOM PICKS TO SET');END
  1813.    ELSE BEGIN
  1814.       WRITELN; WRITELN;
  1815.    END{IF};
  1816.    IF NUMTKTS > 0 THEN BEGIN
  1817.       REPLYVALID := REPLYVALID + [5,6];
  1818.       WRITELN (' 5.  EDIT TICKETS IN SET');
  1819.       WRITELN (' 6.  STORE TICKET SET TO DISK');END
  1820.    ELSE BEGIN
  1821.       WRITELN; WRITELN;
  1822.    END{IF};
  1823.    WRITELN (' 7.  ENTER WINNING TICKET DRAWN');
  1824.    IF ((NUMTKTS > 0) AND (WINNERVALID = TRUE)) THEN BEGIN
  1825.       REPLYVALID := REPLYVALID + [8];
  1826.       WRITELN (' 8.  SCAN TICKET SET FOR WINNERS');END
  1827.    ELSE BEGIN
  1828.       WRITELN;
  1829.    END{IF};
  1830.    IF ((NUMTKTS > 0) OR (WINNERVALID = TRUE)) THEN BEGIN
  1831.       REPLYVALID := REPLYVALID + [9,10];
  1832.       WRITELN (' 9.  PRINT TICKET SET');
  1833.       WRITELN ('10.  DISPLAY TICKET SET');END
  1834.    ELSE BEGIN
  1835.       WRITELN; WRITELN;
  1836.    END{IF};
  1837.    WRITELN ('11.  RUN SIMULATION');
  1838.    WRITELN ('12.  OPTIONS MENU');
  1839.    WRITELN ('13.  DATA FILE DIRECTORY');
  1840.    WRITELN ('14.  ERASE DATA FILE');
  1841.    WRITELN ('15.  RENAME DATA FILE');
  1842.  
  1843.             {GET USER SELECTION AND TEST FOR VALIDITY}
  1844.  
  1845.    REPEAT
  1846.       GoToXY (15,QUESTLINE);
  1847.       CLREOL;
  1848.       WRITE ('ENTER YOUR SELECTION      ');
  1849.       SELECTION := -1; {ENTER DEFAULT}
  1850.       READLN (SELECTION);
  1851.       IOCheckA;
  1852.       IF IOERR = TRUE THEN SELECTION := -1; {RESET AS INVALID ANSWER}
  1853.       IF NOT(SELECTION IN REPLYVALID) THEN BEGIN
  1854.          GoToXY (1,QUESTLINE);
  1855.          CLREOL;
  1856.          GoToXY (10,QUESTLINE);
  1857.          WRITE ('ERROR !!! - ILLEGAL CHOICE, TRY AGAIN');
  1858.          ALERT1 (1);
  1859.          DELAY (1000);
  1860.          GoToXY (1,QUESTLINE);
  1861.          CLREOL;
  1862.          GOTO ENDLOOP;
  1863.       END{IF};
  1864.    UNTIL SELECTION IN REPLYVALID;
  1865.  
  1866.                        {PROCESS VALID RESPONSE}
  1867.  
  1868.    CASE SELECTION OF
  1869.     0 :   DONE:=TRUE;
  1870.     1 :   BEGIN
  1871.              RDISKTKTS;
  1872.              IF AUTODISP = Y THEN DISPTKTS;
  1873.              IF AUTOPRINT = Y THEN PRINTTICKETS;
  1874.           END;
  1875.     2 :   REINIT;
  1876.     3 :   ADDTKTS;
  1877.     4 :   BEGIN
  1878.              RANDOMIZE (0,0);
  1879.              ADDRANDUM;
  1880.              IF AUTODISP = Y THEN DISPTKTS;
  1881.           END;
  1882.     5 :   EDITMENU;
  1883.     6 :   WDISKTKTS;
  1884.     7 :   BUILDWIN;
  1885.     8 :   SCANTKTS;
  1886.     9 :   PRINTTICKETS;
  1887.    10 :   DISPTKTS;
  1888.    11 :   BEGIN
  1889.              REINIT;
  1890.              NUMTKTS := TKTMAX;
  1891.              SIMULATE;
  1892.              SCANTKTS;
  1893.              IF AUTODISP = Y THEN DISPTKTS;
  1894.           END;
  1895.    12 :   OPTMENU;
  1896.    13 :   DISPDIR;
  1897.    14 :   DROPFILE;
  1898.    15 :   RENFILE;
  1899.    END{CASE};
  1900. ENDLOOP :
  1901. UNTIL DONE = TRUE;
  1902. END {PROC};
  1903.  
  1904.       {  MAIN PROGRAM BEGINS HERE ...... MAIN PROGRAM BEGINS HERE  }
  1905.  
  1906.  
  1907. BEGIN {LOTTERY}
  1908.  
  1909.                                {INITIALIZE}
  1910.  
  1911. RANDOMIZE(0,0);
  1912. NOSOUND; {SET UP THE SOUND EFFECTS GENERATOR}
  1913. REINIT;  {ZERO OUT THE DATA ARRAYS}
  1914.  
  1915. {SET KEYBOARD TO CAPS LOCK AND NUM LOCK ON
  1916. THIS IS DONE BY SETTING BITS 6 & 5 OF MEMORY LOCATION 00417H TO 1.}
  1917.  
  1918. STARTBYTE := MEM[$0000:$0417]; {GET STARTING CONDITION OF KBD}
  1919. POKEBYTE := STARTBYTE OR $60; {SET BITS 6 & 5}
  1920. MEM[$0000:$0417] := POKEBYTE; {POKE BACK INTO MEMORY}
  1921.  
  1922. {SET INITIAL OPTIONS}
  1923.  
  1924. PWPRINT := N;
  1925. PWDISP := Y;
  1926. AUTODISP := N;
  1927. AUTOPRINT := N;
  1928.  
  1929.                              {RUN MAIN PROGRAM}
  1930.  
  1931. BANNER; {PRINT OUT A GREETING}
  1932.  
  1933. MAINMENU; {MAIN DRIVER MENU}
  1934.  
  1935.                             {PROGRAM TERMINATION}
  1936.  
  1937. WINDOW (1,1,80,25);
  1938. HILITE;
  1939. ClrScr;
  1940. GoToXY (35,13);
  1941. WRITELN ('GOOD BYE!');
  1942.  
  1943. {RETURN KEYBOARD TO ORIGINAL CONDITION}
  1944.  
  1945. OLDCON := STARTBYTE AND $60; {GET ORIGINAL BITS 6 & 5}
  1946. NOWBYTE := MEM[$0000:$0417]; {GET CURRENT BYTE}
  1947. POKEBYTE := (NOWBYTE AND NOT($60)) OR OLDCON; {MASK OUT BITS 6 & 5 THEN OR IN
  1948.                                                THE OLD VALUES}
  1949. MEM[$0000:$0417] := POKEBYTE; {POKE VALUE BACK INTO MEMORY}
  1950. BEEPBEEP(3);
  1951. END.
  1952.  
  1953.